home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / ESCAPE.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-02  |  22.7 KB  |  719 lines
  1. /* ESCAPE.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *        Handle all %ESCAPE extensions                *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: M. Vuilleumier        Date: 1992            *
  16.  * Revision history:                            *
  17.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18.  *                                    *
  19.  *                    ``In nomine omnipotentii dei''    *
  20.  ************************************************************************/
  21.  
  22. #include    <ctype.h>
  23. #include    <string.h>
  24. #include    <dos.h>
  25. #include    <dir.h>
  26. #include    <math.h>
  27. #include    <io.h>
  28. #include    <stdio.h>
  29. #include    <stdlib.h>
  30. #include    <time.h>
  31. #include    "scheme.h"
  32. #ifdef __cplusplus
  33. extern "C"     void       _Cdecl textmode( int __newmode );
  34. #else
  35.         void       _Cdecl textmode( int __newmode );
  36. #endif
  37.  
  38. #define    DEFSTR    100
  39.         // the default string size scanf can return
  40. /************************************************************************/
  41. /* Scheme to Borland C (or assembly langauge) Interface          */
  42. /*                                    */
  43. /* Purpose:  To provide the ability for a Scheme user to link to low    */
  44. /* level routines not written in Scheme.                */
  45. /*                                    */
  46. /* Description:  This interface allows linkage to routines written in    */
  47. /* Borland C, or assembly langauge routines which use the        */
  48. /* Borland C linkage conventions.                    */
  49. /*                                    */
  50. /* Limitations:  This interface may be used to call routines which    */
  51. /* accept up to 60 arguments of the Borland C types:            */
  52. /*                                    */
  53. /* long    (32 bits integers)                         */
  54. /* char                                     */
  55. /* char * (zero terminated string)                      */
  56. /* double (64 bits float)                         */
  57. /*                                     */
  58. /* and which return a single Scheme value of one of the             */
  59. /* following types:                             */
  60. /*                                     */
  61. /* fix/bignum (up to 32 bits)                         */
  62. /* flonum                                 */
  63. /* character                                 */
  64. /* string                                 */
  65. /* #t or '()                                */
  66. /*                                     */
  67. /* The C and/or assembly language routines may have side         */
  68. /* effects and save state information, but they may not             */
  69. /* have access to, or modify, the state of the Scheme             */
  70. /* runtime (except through the passing of parameters).             */
  71. /*                                     */
  72. /* How to Use:                                */
  73. /*                                    */
  74. /* 1.  Compile the routine you wish to call using the medium model    */
  75. /* (large code, small data) Borland C compiler.                */
  76. /*                                    */
  77. /* 2.  Modify this routine (ESCAPE.C) as follows, and compile it    */
  78. /* with the medium model Borland C compiler.                */
  79. /*                                    */
  80. /* a.    Add a declaration to indicate the type of the value to        */
  81. /* be returned by your external routine, e.g.,                */
  82. /*                                    */
  83. /* char        *dir1( char *, char * );                */
  84. /*                                    */
  85. /* Here, the function "dir1" is declared to return            */
  86. /* (char *), which is the C representation for a character        */
  87. /* string.                                 */
  88. /*                                    */
  89. /* b.    Add an entry in the "switch" statement to call your        */
  90. /* routine.  You must explicitly indicate the type of each        */
  91. /* argument you pass, as well as the value you wish to be        */
  92. /* returned to Scheme.                            */
  93. /*                                    */
  94. /* Argument values may be obtained and converted to the            */
  95. /* appropriate type using a specified member of LINKARG structure:    */
  96. /*                                    */
  97. /*    arg[n].item.i    is the n-th argument as an integer    (long)    */
  98. /*    arg[n].item.b    is the n-th argument as a boolean      (short)    */
  99. /*    arg[n].item.c    is the n-th argument as a character     (char)    */
  100. /*    arg[n].item.f    is the n-th argument as a float          (double)    */
  101. /*    arg[n].item.s    is the n-th argument as a string      (char *)    */
  102. /*                                    */
  103. /* The index of last valid argument is stored in lastArg        */
  104. /* The type of the argument is stored in arg[n].type and is either:    */
  105. /*                                    */
  106. /*    BOOLEAN, INTEGER, FLOAT, CHARACTER or STRING            */
  107. /*                                    */
  108. /* Value must be returned using one of the following assignement    */
  109. /*                                    */
  110. /*     result->i = any_long_variable                    */
  111. /*    result->b = any_short_variable                    */
  112. /*     result->c = any_char_variable                    */
  113. /*     result->f = any_double_variable                    */
  114. /*     result->s = any_char*_variable                    */
  115. /*                                    */
  116. /* and type of return value should be returned as follow :        */
  117. /*                                    */
  118. /*    return    NOVALUE;     if scheme return value is undefined    */
  119. /*    return    INTEGER;     if scheme return value is an integer    */
  120. /*    return    BOOLEAN;     if scheme return value is a boolean    */
  121. /*    return    CHARACTER;     if scheme return value is a character    */
  122. /*    return    FLOAT;         if scheme return value is a float    */
  123. /*    return    STR;         if scheme return value is a string    */
  124. /*    return    STRorNIL;     if scheme return value is either a     */
  125. /*                    string or NIL if char* = nil    */
  126. /*                                    */
  127. /*     You are NOT responsable for freeing the space used by string    */
  128. /* parameters or return value. This will be done by PCS. But you are    */
  129. /* not allowed to modify the argument table, since PCS could loose    */
  130. /* trace of the data he might want to free. Return value are freed    */
  131. /* according to the declared return type (so ensure it is correct).    */
  132. /*                                    */
  133. /* c.    The case number in step b is the "function code" which        */
  134. /* is used to invoke the function.  The function code must        */
  135. /* always be an integer and must be the first operand            */
  136. /* passed the "%esc" Scheme functions.  The other operands follow     */
  137. /* the function code in the order expected by the called routine.    */
  138. /*                                    */
  139. /* For example, to call the "dir1" function with one operand, we code:    */
  140. /*                                    */
  141. /* (%esc 0 "string")                            */
  142. /*                                    */
  143. /* where the first operand (0) is the function code and            */
  144. /* "string" is the character string to be passed as the            */
  145. /* only argument.                            */
  146. /*                                    */
  147. /* d.    To provide a more meaningful calling sequence and to        */
  148. /* check for correct parameters, a Scheme routine should        */
  149. /* be defined for each function to be called.  These            */
  150. /* functions are normally placed in the SCHEME.INI file,        */
  151. /* but may be installed "permanently" for a given            */
  152. /* application by converting them to fast-load format and        */
  153. /* appending them to the FRONT of the COMPILER.FSL file,        */
  154. /* which is automatically loaded when PCS begins.            */
  155. /*                                    */
  156. /* A sample Scheme function for the "dir1" function is:            */
  157. /*                                    */
  158. /* (define dir1                                */
  159. /*   (lambda (filespec)                            */
  160. /*     (if (string? filespec)                         */
  161. /*       (%esc 0 filespec)                        */
  162. /*       (error "Invalid Parameter to 'dir1'" filespec))))         */
  163. /*                                    */
  164. /* Here, the Scheme function "dir1" checks its argument            */
  165. /* to make sure that it's a string and, if it is, uses the        */
  166. /* escape (%esc) opcode to invoke the function.  If the            */
  167. /* argument is not a string, an error is reported through        */
  168. /* the Scheme error procedure.                        */
  169. /*                                    */
  170. /* e.    The Scheme runtime must be re-linked with your Borland        */
  171. /* C and/or assembly language routines included.            */
  172. /* The best would be to put all your code at the end of            */
  173. /* this module. If you really need, you might make a new        */
  174. /* module and link it with the others as follow :            */
  175. /* Modify the MAKEFILE file (the compile-link edit control file)    */
  176. /* to include your modules by adding them to the end of            */
  177. /* the dependencies of PCS.EXE.                        */
  178. /*                                    */
  179. /************************************************************************/
  180. /*                                    */
  181. /*      ESCAPE FUNCTIONS SUMMARY  - please keep it up-to-date !        */
  182. /*    -------------------------------------------------------        */
  183. /*                                    */
  184. /*  Part 1: Miscellanous functions                    */
  185. /*    function code 0:  find file match                */
  186. /*    function code 1:  step through directory, matching files    */
  187. /*    function code 2:  bid another MS-DOS task            */
  188. /*    function code 3:  get the free space of heap            */
  189. /*    function code 4:  scroll window up one line            */
  190. /*    function code 5:  scroll window down one line            */
  191. /*    function code 6:  split a filename into components (fnsplit)    */
  192. /*    function code 7:  software interrupt                */
  193. /*    function code 8:  float->hex conversion                */
  194. /*    function code 9:  return hash value of symbol            */
  195. /*    function code 10: delete a file                    */
  196. /*    function code 11: copy a file                    */
  197. /*    function code 12: rename files under current directory        */
  198. /*    function code 13: sound specified frequency            */
  199. /*    function code 14: nosound (turn the speaker off)        */
  200. /*    function code 15: get the file size                */
  201. /*    function code 16: change current directory            */
  202. /*    function code 17: change current drive                */
  203. /*    function code 18: text-mode function call            */
  204. /*    function code 19: get path                    */
  205. /*    function code 20: seed random number generator            */
  206. /*    function code 21: return compaction variable            */
  207. /*    function code 22: set compaction variable            */
  208. /*  Part 2: Math functions                        */
  209. /*    function code 23: square root                    */
  210. /*    function code 24: sinus                        */
  211. /*    function code 25: cosinus                    */
  212. /*    function code 26: tangent                    */
  213. /*    function code 27: arctangent                    */
  214. /*    function code 28: arccosinus                    */
  215. /*    function code 29: arcsinus                    */
  216. /*    function code 30: natural logarithm                */
  217. /*    function code 31: decimal logarithm                */
  218. /*    function code 32: base n logarithm                */
  219. /*    function code 33: exponential                    */
  220. /*    function code 34: general exponent                */
  221. /*  Part 3: Other functions                        */
  222. /*    function code 35: incremental global env lookup            */
  223. /*    function code 36: get env variable                */
  224. /*    function code 37: set env variable                */
  225. /*    function code 38: complete filename                */
  226. /*    function code 39: sprintf                    */
  227. /*    function code 40: sscanf                    */
  228. /*    function code 41: get cpu                    */
  229. /*    function code 42: set cursor visibility    when enabled (see 47)    */
  230. /*    function code 43: get clock                    */
  231. /*    function code 44: get unix time                    */
  232. /*    function code 45: convert to time structure            */
  233. /*    function code 46: convert from time structure            */
  234. /*    function code 47: set cursor auto-hiding off/on            */
  235. /*                                    */
  236. /************************************************************************/
  237.  
  238. void    schemetime( REGPTR r, struct tm *t )
  239. {
  240.     REG    temp;
  241.  
  242.     temp.page = ADJPAGE(SPECFIX);
  243.     temp.disp = t->tm_isdst, cons( r, &temp, &nil_reg );
  244.     temp.disp = t->tm_yday, cons( r, &temp, r );
  245.     temp.disp = t->tm_wday, cons( r, &temp, r );
  246.     temp.disp = t->tm_year, cons( r, &temp, r );
  247.     temp.disp = t->tm_mon, cons( r, &temp, r );
  248.     temp.disp = t->tm_mday, cons( r, &temp, r );
  249.     temp.disp = t->tm_hour, cons( r, &temp, r );
  250.     temp.disp = t->tm_min, cons( r, &temp, r );
  251.     temp.disp = t->tm_sec, cons( r, &temp, r );
  252. }
  253.  
  254. int    link(LINKVAL *result, int lastArg, LINKARG arg[])
  255. {
  256.     extern int    compact_every;    /* Indicates when to compact      */
  257.  
  258. /************************************************************************/
  259. /*    Add a case entry in the following "switch" statement        */
  260. /* to call your external procedure.  The "case" number            */
  261. /* is the function code which you must use to invoke your        */
  262. /* function.                                */
  263. /************************************************************************/
  264.     switch (arg[0].item.i) {
  265.     case 0:        /* function code 0:  find file match */
  266.         if ( ( result->s = (char *) malloc(24) ) != NULL )
  267.             if ( dir1(arg[1].item.s, result->s) == NULL ) {
  268.                 free(result->s);
  269.                 result->s = NULL;
  270.             }
  271.         return    STRorNIL;
  272.     case 1:        /* function code 1:  step through directory, matching files */
  273.         if ( ( result->s = (char *) malloc(24) ) != NULL )
  274.             if ( dir2(0, result->s) == NULL ) {
  275.                 free(result->s);
  276.                 result->i = NULL;
  277.             }
  278.         return    STRorNIL;
  279.     case 2:        /* function code 2:  bid another MS-DOS task */
  280.                 result->i = bid_task(arg[1].item.s, arg[2].item.s, arg[3].item.s, arg[4].item.s);
  281.                 if (result->i == 0x8000)
  282.                         print_and_exit("[VM FATAL ERROR] DOS-CALL error: unable to restore PC Scheme memory\n");
  283.         return    INTEGER;
  284.     case 3:        /* function code 3:  get the free space of heap */
  285.         result->i = freesp();
  286.         return    INTEGER;
  287.     case 4:        /* function code 4:  scroll window up one line */
  288.         zscroll(arg[1].item.i, arg[2].item.i, arg[3].item.i, arg[4].item.i, arg[5].item.i);
  289.         return    NOVALUE;
  290.     case 5:        /* function code 5:  scroll window down one line */
  291.         zscroll_d(arg[1].item.i, arg[2].item.i, arg[3].item.i, arg[4].item.i, arg[5].item.i);
  292.         return    NOVALUE;
  293.     case 6:        /* function code 6:  split a filename into its components  */
  294.         {
  295.             char    drive[MAXDRIVE], dir[MAXDIR], file[MAXFILE], ext[MAXEXT];
  296.             int    i;
  297.  
  298.             fnsplit(arg[1].item.s, drive, dir, file, ext);
  299.             for ( i = 0; i < MAXDIR; i++ )
  300.                 if ( dir[i] == '\\' ) dir[i] = '/';
  301.             
  302.             result->s = (char *)malloc(MAXPATH + 10);
  303.             sprintf(result->s, "(\"%s\"\"%s\"\"%s\"\"%s\")", drive, dir, file, ext);
  304.         }
  305.         return    STR;
  306.     case 7:        /* function code 7:  software interrupt */
  307.         result->i = sw_int(arg[1].item.i, arg[3].item.i, arg[4].item.i, arg[5].item.i, arg[6].item.i);
  308.         return    arg[2].item.i;
  309.     case 9:        /* function code 9: return hash value of symbol */
  310.         result->i = hash(arg[1].item.s, strlen(arg[1].item.s));
  311.         return    INTEGER;
  312.     case 10:        /* function code 10: delete a file */
  313.         result->i = unlink(arg[1].item.s);
  314.         return    INTEGER;
  315.     case 11:        /* function code 11: copy a file */
  316.         result->i = copy_file(arg[1].item.s, arg[2].item.s);
  317.         return    INTEGER;
  318.     case 12:        /* function code 12: rename files under current directory */
  319.         result->i = rename(arg[1].item.s, arg[2].item.s);
  320.         return    INTEGER;
  321.     case 13:        /* function code 13: sound a specified frequency */
  322.         sound(arg[1].item.i);
  323.         return    NOVALUE;
  324.     case 14:        /* function code 14: nosound (turn speaker off) */
  325.         nosound();
  326.         return    NOVALUE;
  327.     case 15:        /* function code 15: get the file size */
  328.         result->i = filesize(arg[1].item.s);
  329.         return    INTEGER;
  330.     case 16:        /* function code 16: change current directory */
  331.         result->i = chdir(arg[1].item.s);
  332.         return    INTEGER;
  333.     case 17:        /* function code 17: change current drive */
  334.         setdisk(toupper(*arg[1].item.s) - 'A');
  335.         return    NOVALUE;
  336.     case 18:        /* function code 18: textmode support */
  337.         textmode(arg[1].item.i);
  338.         return    NOVALUE;
  339.     case 19:        /* function code 19: get path */
  340.         if ( ( result->s = (char *) malloc(160) ) != NULL ) {
  341.             int drv = toupper( *arg[1].item.s );
  342.  
  343.             strcpy( result->s, "?:\\");
  344.             if( drv >= 'A')
  345.                 result->s[0] = drv;
  346.             else
  347.                 result->s[0] = getdisk() + 'A';
  348.             if( getcurdir( drv - '@', result->s + 3 ) )
  349.             {
  350.                 free(result->s);
  351.                 result->s = NULL;
  352.             }
  353.         }
  354.         return    STRorNIL;
  355.     case 20:        /* function code 20: seed random number generator */
  356.         if( ((signed) arg[1].item.i) == -1 )
  357.             randomize();
  358.         else    srand(arg[1].item.i);
  359.         return    NOVALUE;
  360.     case 22:        /* function code 22: set compaction variable */
  361.         compact_every = arg[1].item.i;
  362.     case 21:        /* function code 21: return compaction variable */
  363.         result->i = compact_every;
  364.         return    INTEGER;
  365.     case 23:        /* function code 23: square root */
  366.         result->f = sqrt (arg[1].item.f);
  367.         return    FLOAT;
  368.     case 24:        /* function code 24: sinus */
  369.         result->f = sin (arg[1].item.f);
  370.         return    FLOAT;
  371.     case 25:        /* function code 25: cosinus */
  372.         result->f = cos (arg[1].item.f);
  373.         return    FLOAT;
  374.     case 26:        /* function code 26: tangent */
  375.         result->f = tan (arg[1].item.f);
  376.         return    FLOAT;
  377.     case 27:        /* function code 27: arctangent */
  378.         if ( lastArg == 2 )
  379.             result->f = atan2 (arg[1].item.f, arg[2].item.f);
  380.         else
  381.             result->f = atan (arg[1].item.f);
  382.         return    FLOAT;
  383.     case 28:        /* function code 28: arccosinus */
  384.         result->f = acos (arg[1].item.f);
  385.         return    FLOAT;
  386.     case 29:        /* function code 29: arcsinus */
  387.         result->f = asin (arg[1].item.f);
  388.         return    FLOAT;
  389.     case 30:        /* function code 30: natural log */
  390.         result->f = log (arg[1].item.f);
  391.         return    FLOAT;
  392.     case 31:        /* function code 31: decimal log */
  393.         result->f = log10 (arg[1].item.f);
  394.         return    FLOAT;
  395.     case 32:        /* function code 32: base n log */
  396.         result->f = ( log (arg[1].item.f) / log (arg[2].item.f) );
  397.         return    FLOAT;
  398.     case 33:        /* function code 33: exponential */
  399.         result->f = exp (arg[1].item.f);
  400.         return    FLOAT;
  401.     case 34:        /* function code 34: general exponent */
  402.         result->f = pow (arg[1].item.f, arg[2].item.f);
  403.         return    FLOAT;
  404.     case 35:        /* incremental known symbols lookup */
  405.         if( arg[1].item.i == -1 ) {
  406.             matchdone();
  407.             return  NOVALUE;
  408.         } else {
  409.             REG    kn_env;
  410.  
  411.             get_maxenv( &kn_env);
  412.             result->s = ilookup( arg[1].item.s, arg[2].item.i, CORRPAGE(kn_env.page), kn_env.disp);
  413.             return    STRorNIL;
  414.         }
  415.     case 36:        /* get env variable */
  416.         {
  417.             result->s = getenv( arg[1].item.s );
  418.             return    STATSTRorNIL;
  419.         }
  420.     case 37:        /* set env variable */
  421.         {
  422.             result->i = putenv( arg[1].item.s );
  423.             return    INTEGER;
  424.         }
  425.     case 38:        /* complete filename */
  426.         {
  427.             result->s = searchpath( arg[1].item.s );
  428.             return    STATSTRorNIL;
  429.         }
  430.     case 39:        /* sprintf */
  431.         {
  432.             char    *buf, newargs[NUM_REGS*sizeof(double)];
  433.             char    *p, *format;
  434.             int    i;
  435.  
  436.             if( (buf = (char *) malloc(2000)) == NULL )
  437.             {
  438. printf_error:                result->s = NULL;
  439.                 if( buf )
  440.                     free( buf );
  441.                 return    STRorNIL;
  442.             }
  443.             if( arg[1].type != STR )
  444.                 goto    printf_error;
  445.             for( p = newargs, format = arg[1].item.s, i = 1; *format; format++ )
  446.             if( *format == '%')
  447.             {
  448.                 int    longs = 0;
  449.  
  450.                 if( *++format == '%')
  451.                     continue;
  452.                 if( ++i > lastArg )
  453.                     goto    printf_error;
  454.                 for( int done = 0; !done; format++ )
  455.                 switch( *format )
  456.                 {
  457.                 case 0:
  458.                 case 'F':    // pointers are invalid
  459.                 case 'N':
  460.                 case 'n':
  461.                 case 'L':    // long doubles too
  462.                     goto    printf_error;
  463.                 case 'h':
  464.                     longs = 0;
  465.                 case 'l':
  466.                     longs = 1;
  467.                     break;
  468.                 case '*':
  469.                     if( arg[i].type != INTEGER )
  470.                         goto    printf_error;
  471.                     *((int *) p)++ = arg[i].item.i;
  472.                     if( ++i > lastArg )
  473.                         goto    printf_error;
  474.                     break;
  475.                 case 's':
  476.                     if( arg[i].type != STR )
  477.                         goto    printf_error;
  478.                     *((char **) p)++ = arg[i].item.s;
  479.                     done = 1;
  480.                     break;
  481.                 case 'd':
  482.                 case 'i':
  483.                 case 'o':
  484.                 case 'u':
  485.                 case 'X':
  486.                 case 'x':
  487.                     if( arg[i].type != INTEGER )
  488.                         goto    printf_error;
  489.                     if( longs )
  490.                         *((long *) p)++ = arg[i].item.i;
  491.                     else    *((short *) p)++ = arg[i].item.b;
  492.                     done = 1;
  493.                     break;
  494.                 case 'E':
  495.                 case 'e':
  496.                 case 'f':
  497.                 case 'G':
  498.                 case 'g':
  499.                     if( arg[i].type != FLOAT )
  500.                         goto    printf_error;
  501.                     *((double *) p)++ = arg[i].item.f;
  502.                     done = 1;
  503.                     break;
  504.                 case 'c':
  505.                     if( arg[i].type != CHARACTER )
  506.                         goto    printf_error;
  507.                     *((int *) p)++ = arg[i].item.c;
  508.                     done = 1;
  509.                     break;
  510.                 }
  511.                 format--;
  512.             }
  513.             if( i != lastArg )
  514.                 goto    printf_error;
  515.  
  516.             if( vsprintf( buf, arg[1].item.s, newargs ) == EOF )
  517.                 goto    printf_error;
  518.             result->s = buf;
  519.             return    STRorNIL;
  520.         }
  521.     case 40:        /* sscanf */
  522. {
  523.     REG    r, s;
  524.     LINKVAL    *ptrs[NUMARGS];
  525.     char    *format;
  526.     int    i, args;
  527.  
  528.     if( arg[1].type != STR || arg[2].type != STR ||
  529.         lastArg != 2 )
  530.     {
  531. scanf_error:    result->s = NULL;
  532.         return    BOOLEAN;
  533.     }
  534.     arg += 3;            /* start with the first 'result' */
  535.     for( format = arg[-1].item.s, i = -1; *format; format++ )
  536.     if( *format == '%')
  537.     {
  538.         int    longs = 0, zapit = 0;
  539.  
  540.         if( *++format == '%')
  541.             continue;
  542.         if( ++i >= NUMARGS )
  543.             goto    scanf_error;
  544.         for( int done = 0; !done; format++ )
  545.         switch( *format )
  546.         {
  547.         case 0:
  548.         case 'F':    // pointers are invalid
  549.         case 'N':
  550.         case 'n':
  551.         case 'L':    // long doubles too
  552.             goto    scanf_error;
  553.         case 'h':
  554.             longs = 0;
  555.         case 'l':
  556.             longs = 1;
  557.             break;
  558.         case '*':
  559.             i--;
  560.             zapit = 1;
  561.             break;
  562.         case 's':
  563.         {
  564.             if( !zapit )
  565.             {
  566.                 int    size = 0, mult = 1;
  567.                 char    *f = format - 1;
  568.                 while( *f >= '0' && *f <= '9')
  569.                 {
  570.                     size += (*f-- - '0') * mult;
  571.                     mult *= 10;
  572.                 }
  573.                 if( size <= 0 )
  574.                     size = DEFSTR;
  575.                 if( !(ptrs[i] = (LINKVAL *) malloc(size+1)) )
  576.                     goto    scanf_error;
  577.                 arg[i].type = STR;
  578.             }
  579.             done = 1;
  580.             break;
  581.         }
  582.         case 'D':
  583.         case 'd':
  584.         case 'I':
  585.         case 'i':
  586.         case 'O':
  587.         case 'o':
  588.         case 'U':
  589.         case 'u':
  590.         case 'X':
  591.         case 'x':
  592.             if( !zapit )
  593.             {
  594.                 ptrs[i] = &arg[i].item;
  595.                 arg[i].type = INTEGER;
  596.                 arg[i].item.i = 0;
  597.             }
  598.             done = 1;
  599.             break;
  600.         case 'E':
  601.         case 'e':
  602.         case 'f':
  603.         case 'G':
  604.         case 'g':
  605.             if( !zapit )
  606.             {
  607.                 if( !longs )
  608.                     goto    scanf_error;
  609.                 ptrs[i] = &arg[i].item;
  610.                 arg[i].type = FLOAT;
  611.             }
  612.             done = 1;
  613.             break;
  614.         case 'c':
  615.             if( !zapit )
  616.             {
  617.                 ptrs[i] = &arg[i].item;
  618.                 arg[i].type = CHARACTER;
  619.             }
  620.             done = 1;
  621.             break;
  622.         }
  623.         format--;
  624.     }
  625.     if( (args = vsscanf( arg[-2].item.s, arg[-1].item.s, ptrs )) == EOF )
  626.         goto    scanf_error;
  627.     for( int k = i; k >= args; k-- )    /* free the unused args */
  628.     if( arg[k].type == STR )
  629.         free( ptrs[k] );
  630.     r = nil_reg;
  631.     for( k = args-1; k >= 0; k-- )    /* now actually return the stuff */
  632.     {
  633.         switch( arg[k].type )
  634.         {
  635.         case INTEGER:
  636.             long2int( &s, arg[k].item.i );
  637.             break;
  638.         case FLOAT:
  639.             alloc_flonum( &s, arg[k].item.f );
  640.             break;
  641.         case CHARACTER:
  642.             s.page = ADJPAGE(SPECCHAR);
  643.             s.disp = arg[k].item.c;
  644.             break;
  645.         case STR:
  646.             alloc_string( &s, (char *) ptrs[k] );
  647.             free( ptrs[k] );
  648.             break;
  649.         }
  650.         cons( &r, &s, &r );
  651.     }
  652.     result->r = r;
  653.     return    SCHEME;
  654. }
  655.     case 41:        /* get cpu */
  656.     {
  657.         REG    f1, f2;
  658.         static unsigned    ndp[] = { 0, 87, 287, 387 };
  659.  
  660.         f1.page = f2.page = ADJPAGE(SPECFIX);
  661.  
  662.         cputype( &f1, &f2 );
  663.         cons( &f1, &f1, &f2 );
  664.         f2.disp = ndp[_8087];
  665.         {
  666.             char    far *p = (char far *) 0xf8000000;
  667.             REG    checksum;
  668.             checksum.page = ADJPAGE(SPECFIX), checksum.disp = 0;
  669.  
  670.             for( unsigned i = 0; i < 0x8000; i++ )
  671.                 checksum.disp = checksum.disp * 7 + p[i];
  672.             cons( &checksum, &checksum, &nil_reg );
  673.             cons( &f2, &f2, &checksum );
  674.             cons( &f1, &f1, &f2 );
  675.         }
  676.         result->r = f1;
  677.         return    SCHEME;
  678.     }
  679.     case 42:         /* set cursor visibility when enabled */
  680.         if (arg[1].item.i) {
  681.             zputcur(arg[2].item.i, arg[3].item.i);
  682.             zcuron();
  683.         } else
  684.             zcuroff();
  685.         return    NOVALUE;
  686.     case 43:        /* get clock */
  687.         result->i = clock();
  688.         return    INTEGER;
  689.     case 44:        /* get unix time */
  690.         result->i = time( NULL );
  691.         return    INTEGER;
  692.     case 45:        /* convert to time structure */
  693.         schemetime( &result->r, (arg[1].item.i ? gmtime : localtime)( &arg[2].item.i ) );
  694.         return    SCHEME;
  695.     case 46:        /* convert from time structure */
  696.     {
  697.         struct tm t;
  698.         t.tm_sec = arg[2].item.i;
  699.         t.tm_min = arg[3].item.i;
  700.         t.tm_hour = arg[4].item.i;
  701.         t.tm_mday = arg[5].item.i;
  702.         t.tm_mon = arg[6].item.i;
  703.         t.tm_year = arg[7].item.i;
  704.         result->i = mktime( &t );
  705.         if( arg[1].item.i )
  706.         {
  707.             schemetime( &result->r, &t );
  708.             return    SCHEME;
  709.         }
  710.         return    INTEGER;
  711.     }
  712.     case 47:        /* automatic cursor hiding off/on */
  713.         zautohiding(arg[1].item.i);
  714.         return    NOVALUE;
  715.     default:
  716.         return    ERROR;    /* unrecognized function code */
  717.     }
  718. }
  719.